home *** CD-ROM | disk | FTP | other *** search
/ Dr. Windows 3 / dr win3.zip / dr win3 / WINPROGS / DLGDSN41.ZIP / PASSRC1.PAS < prev    next >
Pascal/Delphi Source File  |  1994-01-02  |  15KB  |  576 lines
  1. {$A-,B-,E+,F-,G-,I+,N-,O-,P-,Q-,R-,S-,T-,V-,X+}
  2. {$M 16384,5000,655360}
  3.  
  4. Program PasSrc1;
  5.  
  6. uses Dos, Objects, {Drivers, Views, Dialogs,
  7.      Editors, Validate,} Dialogs, ReadScpt;
  8.  
  9. const
  10. (*  dpBlueDialog = 0;
  11.   dpCyanDialog = 1;
  12.   dpGrayDialog = 2;  *)
  13.  
  14.   NeedControl1 : boolean = False;
  15. var
  16.   P : PScriptRec;
  17.   Outf : Text;
  18.   DlgName : string[50];  {holds dialog's variable name for easy reference}
  19.  
  20. function Positn(Pat, Src : String; I : Integer) : Integer;
  21. {find the position of a substring in a string starting at the Ith char}
  22. var
  23.   N : Integer;
  24. begin
  25. if I < 1 then I := 1;
  26. Delete(Src, 1, I-1);
  27. N := Pos(Pat, Src);
  28. if N = 0 then Positn := 0
  29.   else Positn := N+I-1;
  30. end;
  31.  
  32. FUNCTION Quoted(S : string) : string;
  33. {If first char is '@' then removes the '@' and otherwise does nothing--
  34.    assumes string is a variable name.
  35.  else
  36.    Puts single quotes around a string and doubles any internal single quotes}
  37. var
  38.   I : Integer;
  39. begin
  40. I := Pos('@', S);
  41. if I = 1 then
  42.   begin
  43.   Quoted := Copy(S, 2, 255);
  44.   Exit;
  45.   end;
  46. I := Pos('''', S);
  47. while I > 0 do
  48.   begin
  49.   Insert('''', S, I);
  50.   I := Positn('''', S, I+2);
  51.   end;
  52. Insert('''', S, 1);
  53. Quoted := S+'''';
  54. end;
  55.  
  56. procedure RDotAssign(P : PScriptRec);
  57. begin
  58. with P^.MainBlock do
  59.   begin
  60.   WriteLn(Outf, 'R.Assign(', X1, ', ', Y1, ', ', X2,', ', Y2, ');');
  61.   end;
  62. end;
  63.  
  64. procedure DoOpEvent(P : PScriptRec; const Sym : string);
  65. var
  66.   S : string;
  67. begin
  68. with P^.MainBlock do
  69.   begin
  70.   if DefOptns <> Optns then
  71.     begin
  72.     Write(Outf, Sym, '^.Options := ');
  73.     S := OptionStr(Optns, DefOptns, GetOptionWords);
  74.     if S[1] = '$' then
  75.       WriteLn(OutF, S)
  76.     else WriteLn(OutF, Sym, '^.Options', S);
  77.     end;
  78.   if DefEvMsk <> EvMsk then
  79.     begin
  80.     Write(Outf, Sym, '^.EventMask := ');
  81.     S := OptionStr(EvMsk, DefEvMsk, GetEventWords);
  82.     if S[1] = '$' then
  83.       WriteLn(OutF, S)
  84.     else WriteLn(OutF, Sym, '^.EventMask', S);
  85.     end;
  86.   end;
  87. end;
  88.  
  89. PROCEDURE WriteHelpCtx(Rf : PString; H : String; Ctx : word);
  90. Const
  91.   NoContext : String[11] = 'hcNoContext';
  92. begin
  93. if (H = '') and (Ctx > 0) then
  94.    Str(Ctx, H);
  95. if (H <> '') and not SameString(H, NoContext) then
  96.   WriteLn(OutF, Rf^, '^.HelpCtx := ', H, ';' );
  97. end;
  98.  
  99. procedure WriteButton(P : PScriptRec); {write code for TButton}
  100. var
  101.   S : string[55];
  102.  
  103.   function FlagStr : string;
  104.   var
  105.     S : string[55];
  106.   begin
  107.   with P^ do
  108.     begin
  109.     S := '';
  110.     if Flags = 0 then S := 'bfNormal'
  111.     else
  112.       begin
  113.       if Flags and 1 <> 0 then S := 'bfDefault or ';
  114.       if Flags and 2 <> 0 then S := S+'bfLeftJust or ';
  115.       if Flags and 4 <> 0 then S := S+'bfBroadcast or ';
  116.       if Flags and 8 <> 0 then S := S+'bfGrabFocus or ';
  117.       Dec(S[0], 4);  {remove extra ' or '}
  118.       end;
  119.     end;
  120.   FlagStr := S;
  121.   end;
  122.  
  123. begin
  124. with P^, MainBlock do
  125.   begin
  126.   RDotAssign(P);
  127.   if SameString(Obj^, 'POptionButton') then  {a special TOptionButton}
  128.     WriteLn(OutF, VarName^, ' := New(', Obj^, ', Init(R, ', Param[1]^,
  129.          ', '+Param[2]^+'));' )
  130.   else
  131.     begin   {regular button}
  132.     if CommandName^ <> '' then S := CommandName^
  133.       else Str(CommandValue, S);
  134.     Write(OutF, VarName^, ' := New(', Obj^, ', Init(R, ',
  135.          Quoted(ButtonText^), ', '+S+', ' );
  136.     WriteLn(OutF, FlagStr+'));' );
  137.     end;
  138.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  139.   DoOpEvent(P, VarName^);
  140.   WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
  141.   end;
  142. end;
  143.  
  144. procedure WriteInputLong(P : PScriptRec);  {code for TInputLong}
  145. begin
  146. with P^, MainBlock do
  147.   begin
  148.   RDotAssign(P);
  149.   WriteLn(OutF,
  150.          VarName^, ' := New('+Obj^+', Init(R, ', LongStrLeng,
  151.          ', ', LLim, ', ', ULim,  ', ', ILOptions, '));' );
  152.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  153.   DoOpEvent(P, VarName^);
  154.   WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
  155.   end;
  156. end;
  157.  
  158. procedure WriteInputLine(P : PScriptRec); {code for TInputLine}
  159. var
  160.   S : string[15];
  161.  
  162.   function DoubleInsideQuotes(St : string) : string;
  163.   var
  164.     I : integer;
  165.   begin
  166.   I := Pos('''', St);
  167.   while I > 0 do
  168.     begin
  169.     Insert('''', St, I);
  170.     I := Positn('''', St, I+2);
  171.     end;
  172.   DoubleInsideQuotes := St;
  173.   end;
  174.  
  175. begin
  176. with P^, MainBlock do
  177.   begin
  178.   RDotAssign(P);
  179.   WriteLn(OutF,
  180.          VarName^, ' := New('+Obj^+', Init(R, ', StringLeng, '));' );
  181.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  182.   DoOpEvent(P, VarName^);
  183.   WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
  184.  
  185.   if ValKind in [Picture..StringLookup] then
  186.     begin
  187.     Write(OutF, '  ', Obj^+'('+VarName^+')^.Validator := New(', ValPtrName^,
  188.         ', Init(');
  189.     case ValKind of
  190.       Picture:
  191.          begin
  192.          if AutoFill <> 0 then S := 'True' else S := 'False';
  193.          {Note: PictureString may start with '@'}
  194.          WriteLn(OutF, '''', DoubleInsideQuotes(PictureString^), ''', ', S, '));');
  195.          end;
  196.       Range:
  197.          begin
  198.          WriteLn(OutF, LowLim, ', ', UpLim, '));');
  199.          if Transfer <> 0 then
  200.            WriteLn(OutF, '  ',
  201.                Obj^+'('+VarName^+')^.Validator^.Options := voTransfer;');
  202.          end;
  203.       Filter:
  204.          WriteLn(OutF, CharSet^, '));');
  205.       StringLookup:
  206.          WriteLn(OutF, List^, '));');
  207.       end;
  208.     end;
  209.   end;
  210. end;
  211.  
  212. procedure WriteMemo(P : PScriptRec);
  213. begin
  214. with P^, MainBlock do
  215.   begin
  216.   RDotAssign(P);
  217.   Write(OutF,
  218.          VarName^, ' := New('+Obj^+', Init(R, ');
  219.   if HScroll^ <> '' then
  220.     Write(OutF, 'PScrollbar(Control1), ')
  221.   else Write(OutF, 'Nil, ' );
  222.   if VScroll^ <> '' then
  223.     Write(OutF, 'PScrollbar(Control), ')
  224.   else Write(OutF, 'Nil, ' );
  225.   WriteLn(OutF, 'Nil, ', BufSize, '));');
  226.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  227.   DoOpEvent(P, VarName^);
  228.   WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
  229.   end;
  230. end;
  231.  
  232. procedure WriteListBox(P : PScriptRec);
  233. begin
  234. with P^, MainBlock do
  235.   begin
  236.   RDotAssign(P);
  237.   Write(OutF,
  238.          VarName^, ' := New('+Obj^+', Init(R, ', Columns);
  239.   if Scrollbar^ <> '' then
  240.     WriteLn(OutF, ', PScrollbar('+ScrollBar^+')));')
  241.   else WriteLn(OutF, ', Nil));' );
  242.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  243.   DoOpEvent(P, VarName^);
  244.   WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
  245.   end;
  246. end;
  247.  
  248. procedure WriteScrollBar(P : PScriptRec);
  249. begin
  250. with P^, MainBlock do
  251.   begin
  252.   RDotAssign(P);
  253.   WriteLn(OutF,
  254.          VarName^, ' := New('+Obj^+', Init(R));');
  255.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  256.   DoOpEvent(P, VarName^);
  257.   WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
  258.   end;
  259. end;
  260.  
  261. procedure WriteCheckRadio(P : PScriptRec);
  262. var
  263.   I : integer;
  264.  
  265.   function MCBFlagString(Flags : word) : string;
  266.   var
  267.     S : string[30];
  268.   begin
  269.   if Flags = $101 then S := 'cfOneBit'
  270.   else if Flags = $203 then S := 'cfTwoBits'
  271.   else if Flags = $40F then S := 'cfFourBits'
  272.   else if Flags = $8FF then S := 'cfEightBits'
  273.   else S := '$'+Hex4(Flags);
  274.   MCBFlagString := S;
  275.   end;
  276.  
  277. begin
  278. with P^, MainBlock do
  279.   begin
  280.   RDotAssign(P);
  281.   Write(OutF,
  282.          VarName^, ' := New('+Obj^+', Init(R, ');
  283.   for I := 0 to Items-1 do
  284.     Write(OutF, ^M^J'  NewSItem(', Quoted(PString(LabelColl^.At(I))^), ',');
  285.   Write(OutF, ' Nil)');
  286.   for I := 1 to Items-1 do
  287.     Write(OutF, ')');
  288.   if Kind = MultiCB then
  289.     Write(OutF, ', ', SelRange, ', ', MCBFlagString(MCBFlags), ', ', Quoted(States^));
  290.   WriteLn(OutF, '));');
  291.   if Mask <> -1 then
  292.     WriteLn(OutF, 'PCluster('+VarName^+')^.SetButtonState($', Hex8(not Mask), ', False);');
  293.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  294.   DoOpEvent(P, VarName^);
  295.   WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
  296.   end;
  297. end;
  298.  
  299. procedure WriteHistory(P : PScriptRec);
  300. begin
  301. with P^, MainBlock do
  302.   begin
  303.   Write(OutF, '  ');
  304.   RDotAssign(P);
  305.   WriteLn(OutF, '  ', DlgName, '^.Insert(New(PHistory, Init(R, PInputline(',
  306.                     HistoryLink^, '), ', HistoryID, ')));');
  307.   end;
  308. end;
  309.  
  310. procedure WriteStaticText(P : PScriptRec);
  311.   procedure DoAtText;
  312.   var
  313.     S : string;
  314.     I : integer;
  315.   begin
  316.   S := P^.Text^;
  317.   I := Pos(^C, S);
  318.   while I > 0 do
  319.     begin
  320.